home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / VTOOLS / VTFAST.PAS < prev    next >
Pascal/Delphi Source File  |  1995-03-24  |  16KB  |  575 lines
  1. UNIT VTFAST; { Fast Screen operations & etc.}
  2.  
  3. INTERFACE
  4. Const MaxBoxTypes = 2;
  5.             Type BoxType = Record
  6.                               LeftVLine,
  7.                               RightVline,
  8.                               UpHLine,
  9.                               DownHline,
  10.                               LUCorner,
  11.                               RUCorner,
  12.                               LDCorner,
  13.                               RDCorner : Char;
  14.                              End;
  15.                 Boxes =  array [0..MaxBoxTypes] of BoxType;
  16.  Const      VPageL : Word = 4256; { Video Page Length }
  17. {============== DEFINES DRAWING BOX CHARACTERS ================}
  18.        Box :  Boxes =((), (),(){*=-- EXTEND HERE TO MaxBoxTypes--=*} );
  19.        CursorTop : Byte = 0;
  20.        CursorBot : Byte = 0;
  21.          TempBot : Byte = 0;
  22.          TempTop : Byte = 0;
  23.     ExplodeSpeed : Word = 20000; {* = 65535 No delay *}
  24.  
  25.  VAR      VSeg, { Video segment /$B800/ }
  26.           VOFF, { Video offset /Current Video Page * VPageL/ }
  27.      VideoInfo, { Video Information Word }
  28.           VPage : Word; { Current Video Page }
  29.  
  30. {****  MAIN INFORMATION FUNCTIONS ****}
  31.  Function DetectVideo : word;
  32.  Function ColorScreen : Boolean;
  33.  Function CurrentPage : Byte;
  34. Procedure SetPage(Page : Byte);
  35. Procedure Cls(Attr : Word);
  36.  Function EGAVGASystem : boolean;
  37. {**** EXTERNAL FAST TYPING PROCEDURES ****}
  38. Procedure PlainWrite(col,row : Word; StrW : String);
  39. Procedure ColorWrite(col,row,F,B : Word; StrW : String);
  40. Procedure SetCharAttr(col,row,attr : Word);
  41. {**** CURSOR ROUTINES ****}
  42. Procedure HideCursor;
  43. Procedure ShowCursor;
  44. Procedure HalfCursor;
  45. Procedure FullCursor;
  46. Procedure SmallCursor;
  47. Procedure SetCursor(Bot,top : Byte);
  48. Procedure GetCursor(Var Bot,top : Byte);
  49. Procedure XY(X,Y : Byte);
  50. Procedure GetXY(Var X,Y : Byte);
  51. {**** CHAR ROUTINES ****}
  52. Procedure PlainWriteChar(Col,Row : Byte;Ch : Char);
  53. Procedure ColorWriteChar(Col,Row,F,B : Byte;Ch : Char);
  54.  Function GetCharFromScreen( Col,Row : Byte) : Char;
  55.  Function GetCharAttrFromScreen( Col,Row : Byte) : Byte;
  56. Procedure GetCharAttributes(Col,Row : Byte;Var F,B : Word);
  57. {**** DESIGN ROUTINES ****}
  58. Procedure PlainClearText(X,Y,X1,Y1 : Byte);
  59. Procedure ClearText(X,Y,X1,Y1,F,B : Byte);
  60. Procedure DrawBox(X,Y,X1,Y1,BoxT : Byte);
  61. Procedure DrawFillBox(X,Y,X1,Y1,F,B,BoxT : Byte);
  62. Procedure ExplodeBox(X,Y,X1,Y1,F,B,BoxT : Byte);
  63. Procedure PlainWriteVert(X,Y : Byte;Txt : String);
  64. Procedure ColorWriteVert(X,Y,F,B : Byte;Txt : String);
  65. Procedure PlainHorizLine(X,X1,Y,LineType : Byte);
  66. Procedure ColorHorizLine(X,X1,Y,F,B,LineType : Byte);
  67. Procedure PlainVertLine(X,Y,Y1,LineType : Byte);
  68. Procedure ColorVertLine(X,Y,Y1,F,B,LineType : Byte);
  69. Procedure PlainWriteCenter(Line : Byte;Txt : String);
  70. Procedure ColorWriteCenter(Line,F,B : Byte;Txt : String);
  71. Procedure PlainWriteBetween(X,X1,Y : Byte; Txt : String);
  72. Procedure ColorWriteBetween(X,X1,Y,F,B : Byte; Txt : String);
  73.  
  74. {**** OTHER ROUTINES ****}
  75.  Function ReplicateChar(N : Byte; Ch : Char) : String;
  76.  Function Attrib(F,B : Byte) : Byte;
  77. Procedure SetBlink (Stat : Boolean);
  78. Procedure FillScreen(F,B : Byte; Ch : Char);
  79. Procedure PartFillScreen(X,Y,X1,Y1,F,B : Byte; Ch : Char);
  80. Procedure ScrollUp(X,Y,X1,Y1,Num,Attr : Byte);
  81. Procedure ScrollDown(X,Y,X1,Y1,Num,Attr : Byte);
  82. IMPLEMENTATION
  83.  
  84. {$L VTFAST.OBJ}
  85. {$F+}
  86. Procedure PlainWrite(col,row : Word; StrW : String); External;
  87. Procedure ColorWrite(col,row,F,B : Word; StrW : String); External;
  88. Procedure SetCharAttr(col,row,attr : Word); External;
  89. Procedure Cls(Attr : Word); External;
  90. {$F-}
  91. Procedure FastError(ECode : Byte);
  92. Begin
  93.  Write('VTFAST Runtime Error: ',Ecode);
  94.  Case Ecode of
  95.         1 : WriteLn('. Invalid range requested!');
  96.  End;
  97.  Halt;
  98. End;
  99. {===========================================================================
  100.                  ** MAIN INFORMATION FUNCTIONS **
  101.  ===========================================================================}
  102. Function DetectVideo : word; assembler;
  103. asm
  104.  mov ax,0f00h
  105.  int 10h
  106. End;
  107.  
  108. Function ColorScreen : Boolean; assembler;
  109. asm
  110.  mov ax,0f00h
  111.  int 10h
  112.  cmp al,07h
  113.  jne @NotMonochrome
  114.   xor ax,ax
  115.  jmp @EndColorScreen
  116.  @NotMonochrome:
  117.   mov ax,01h
  118.  @EndColorScreen:
  119. End;
  120.  
  121. Function CurrentPage : Byte; assembler;
  122. asm
  123.  mov ax,0f00h
  124.  int 10h
  125.  mov al,bh
  126. end;
  127.  
  128. Procedure SetPage(Page : Byte);
  129. Begin
  130. asm
  131.  mov al,Page
  132.  mov ah,05h
  133.  int 10h
  134. End;
  135.  VOff := Page * VPageL;
  136. end;
  137.   Function EGAVGASystem : boolean; assembler;
  138.   asm
  139.     MOV AX,1C00h
  140.     MOV CX,7
  141.      INT 10h
  142.      CMP AL,1Ch {VGA ?}
  143.      JNE @MCGACheck
  144.      MOV AL,1
  145.      XOR CX,CX
  146.      JMP @EndProc
  147.    @MCGACheck:
  148.      MOV AX,1200h
  149.      MOV BL,32h
  150.       INT  10h
  151.      CMP AL,12h {MCGA ?}
  152.      JNE @EGACheck
  153.      XOR CX,CX
  154.      MOV AL,1
  155.      JMP @EndProc
  156.    @EGACheck:
  157.      MOV AH,12h
  158.      MOV BL,10h
  159.      MOV CX,0FFFFh
  160.       INT 10h
  161.      CMP CX,0FFFFh {EGA ?}
  162.      JE @EndProc
  163.      MOV AL,1
  164.      XOR CX,CX
  165.    @EndProc:
  166.     CMP CX,0
  167.      JE @EGAVGAPresent
  168.     XOR AL,AL
  169.   @EGAVGAPresent:
  170.   end;
  171.  
  172. {===========================================================================
  173.                  ** CURSOR ROUTINES **
  174.  ===========================================================================}
  175.  
  176. Procedure HideCursor;
  177. Begin
  178. If TempTop <> 32 Then GetCursor(TempTop,TempBot);
  179.   asm
  180.    MOV AH,01
  181.    MOV CH,32d
  182.    MOV CL,0
  183.     INT 10H
  184.   End;
  185. End;
  186. Procedure ShowCursor;
  187. Begin
  188.  SetCursor(TempTop,TempBot);
  189. End;
  190. Procedure HalfCursor;
  191. Begin
  192.  SetCursor(7,4);
  193. End;
  194. Procedure FullCursor;
  195. Begin
  196.  SetCursor(7,0);
  197. End;
  198. Procedure SmallCursor;
  199. Begin
  200.  SetCursor(7,6);
  201. End;
  202. Procedure SetCursor(Bot,Top : Byte); assembler;
  203. asm
  204.   MOV AH,01
  205.   MOV CH,BYTE PTR top
  206.   MOV CL,BYTE PTR Bot
  207.    INT 10h
  208. End;
  209. Procedure GetCursor(Var Bot,Top : Byte); assembler;
  210. asm
  211.    MOV AH,03
  212.    MOV BH,1
  213.     INT 10h
  214.    MOV AX,CX
  215.    LES DI,Bot
  216.     STOSB
  217.    ROR AX,8
  218.    LES DI,Top
  219.     STOSB
  220. End;
  221. Procedure XY(X,Y : Byte); assembler;
  222. asm
  223.    MOV AH,02
  224.    MOV BX,WORD PTR VPage
  225.    MOV DH,BYTE PTR Y
  226.    MOV DL,BYTE PTR X
  227.    DEC DH
  228.    DEC DL
  229.     INT 10H
  230. End;
  231. Procedure GetXY(Var X,Y : Byte); assembler;
  232. asm
  233.    MOV AH,03
  234.    MOV BX,WORD PTR VPage
  235.    INC BX
  236.     INT 10h
  237.    INC DH
  238.    INC DL
  239.    LES DI,Y
  240.    MOV AL,DH
  241.     STOSB
  242.    LES DI,X
  243.    MOV AL,DL
  244.     STOSB
  245. End;
  246.  
  247. {===========================================================================
  248.                  ** CHAR ROUTINES **
  249.  ===========================================================================}
  250. Procedure PlainWriteChar(Col,Row : Byte;Ch : Char);
  251. Begin
  252.  PlainWrite(Col,Row,Ch);
  253. End;
  254. Procedure ColorWriteChar(Col,Row,F,B : Byte;Ch : Char);
  255. Begin
  256.  ColorWrite(Col,Row,F,B,Ch);
  257. End;
  258.  
  259.  Function GetCharFromScreen(Col,Row : Byte) : Char; assembler;
  260.  Asm
  261.   PUSH DS
  262.    XOR BX,BX
  263.    XOR AX,AX
  264.    MOV AL,BYTE PTR Col
  265.    MOV BL,BYTE PTR Row
  266.    DEC AX
  267.    DEC BX
  268.    SHL BX,8
  269.    SHR BX,1
  270.    MOV Si,BX
  271.    SHR SI,2
  272.    ADD SI,BX
  273.    SHL AX,1
  274.    ADD SI,AX
  275.    ADD SI,VOff
  276.    MOV DS,VSeg
  277.    XOR AX,AX
  278.     LODSB
  279.   POP  DS
  280.  End;
  281.  Function GetCharAttrFromScreen(Col,Row : Byte) : Byte; assembler;
  282.  Asm
  283.   PUSH DS
  284.    XOR BX,BX
  285.    XOR AX,AX
  286.    MOV AL,BYTE PTR Col
  287.    MOV BL,BYTE PTR Row
  288.    DEC AX
  289.    DEC BX
  290.    SHL BX,8
  291.    SHR BX,1
  292.    MOV Si,BX
  293.    SHR SI,2
  294.    ADD SI,BX
  295.    SHL AX,1
  296.    ADD SI,AX
  297.    ADD SI,VOff
  298.    INC SI
  299.    MOV DS,VSeg
  300.    XOR AX,AX
  301.     LODSB
  302.   POP  DS
  303.  End;
  304. Procedure GetCharAttributes(Col,Row : Byte;Var F,B : Word);
  305. Var Tmp : Byte;
  306.  Begin
  307.    Tmp := GetCharAttrFromScreen(Col,Row);
  308.    B := Tmp DIV 16;
  309.    F := Tmp MOD 16;
  310.  End;
  311. {===========================================================================
  312.                  ** DESIGN ROUTINES **
  313.  ===========================================================================}
  314.  
  315. Procedure PlainClearText(X,Y,X1,Y1 : Byte);
  316. Var i : Byte;
  317. Begin
  318.  If X1-X+1 < 1 Then FastError(1);
  319.  For i := Y to Y1 Do PlainWrite(X,i,ReplicateChar(X1-X+1,' '));
  320. End;
  321. Procedure ClearText(X,Y,X1,Y1,F,B : Byte);
  322. Var i : Byte;
  323. Begin
  324.  If X1-X+1 < 1 Then FastError(1);
  325.  For i := Y to Y1 Do ColorWrite(X,i,F,B,ReplicateChar(X1-X+1,' '));
  326. End;
  327.  
  328. Procedure DrawBox(X,Y,X1,Y1,BoxT : Byte);
  329. Var I : Byte;
  330. Begin
  331.  If X < 1 Then FastError(1);
  332.  If X1-X-1 < 1 Then FastError(1);
  333.  If BoxT > MaxBoxTypes Then FastError(1);
  334.  PlainWrite(X+1,Y,ReplicateChar(X1-X-1,Box[Boxt].UpHLine));
  335.  PlainWrite(X+1,Y1,ReplicateChar(X1-X-1,Box[Boxt].UpHLine));
  336.  For I := Y+1 To Y1-1 Do Begin
  337.                            PlainWrite(X,I,Box[BoxT].LeftVLine);
  338.                            PlainWrite(X1,I,Box[BoxT].LeftVLine);
  339.                          End;
  340.  With Box[BoxT] Do Begin
  341.                     PlainWrite(X,Y,LUCorner);
  342.                     PlainWrite(X1,Y,RUCorner);
  343.                     PlainWrite(X,Y1,LDCorner);
  344.                     PlainWrite(X1,Y1,RDCorner);
  345.                    End;
  346. End;
  347. Procedure DrawFillBox(X,Y,X1,Y1,F,B,BoxT : Byte);
  348. Var I : Byte;
  349. Begin
  350.  If X < 1 Then FastError(1);
  351.  If X1-X-1 < 1 Then FastError(1);
  352.  If BoxT > MaxBoxTypes Then FastError(1);
  353.  ClearText(X,Y,X1,Y1,F,B);
  354.  ColorWrite(X+1,Y,F,B,ReplicateChar(X1-X-1,Box[Boxt].UpHLine));
  355.  ColorWrite(X+1,Y1,F,B,ReplicateChar(X1-X-1,Box[Boxt].UpHLine));
  356.  For I := Y+1 To Y1-1 Do Begin
  357.                            ColorWrite(X,I,F,B,Box[BoxT].LeftVLine);
  358.                            ColorWrite(X1,I,F,B,Box[BoxT].LeftVLine);
  359.                          End;
  360.  With Box[BoxT] Do Begin
  361.                     ColorWrite(X,Y,F,B,LUCorner);
  362.                     ColorWrite(X1,Y,F,B,RUCorner);
  363.                     ColorWrite(X,Y1,F,B,LDCorner);
  364.                     ColorWrite(X1,Y1,F,B,RDCorner);
  365.                    End;
  366. End;
  367.  
  368. Procedure ExplodeBox(X,Y,X1,Y1,F,B,BoxT : Byte);
  369.   Var MidX,MidY,
  370.    MaxPases,Tmp,
  371.       TmpX,TmpY,
  372.             Cnt : Byte;  
  373.              dr : Word;
  374.  
  375.  Function Minimal (First,Second : Byte) : Byte;
  376.  Begin
  377.    Minimal := First;
  378.    If First > Second Then Minimal := Second;
  379.  End;
  380.  
  381. Begin {* ExplodeBox *}
  382.  MidX := (X+X1) Div 2; TmpX := MidX-X;
  383.  MidY := (Y+Y1) Div 2; TmpY := MidY-Y;
  384.  Tmp := TmpX DIV TmpY;
  385.  If Tmp = 0 Then Tmp := TmpY Div TmpX;
  386.  MaxPases := Minimal(TmpX,TmpY);
  387.  For Cnt := 1 To MaxPases Do Begin For DR := MidX-Cnt*Tmp To MidX+Cnt*Tmp DO
  388.                                        Begin
  389.                                         SetCharAttr(Dr,MidY-Cnt,Attrib(F,B));
  390.                                         SetCharAttr(Dr,MidY+Cnt,Attrib(F,B));
  391.                                        End;
  392.                                    For Dr := MidY-Cnt To MidY+Cnt DO
  393.                                        Begin
  394.                                         SetCharAttr(MidX-Cnt*Tmp,DR,Attrib(F,B));
  395.                                         SetCharAttr(MidX+Cnt*Tmp,DR,Attrib(F,B));
  396.                                        End;
  397.                                    DrawBox(MidX-Cnt*Tmp,MidY-Cnt,
  398.                                                MidX+Cnt*Tmp,MidY+Cnt,
  399.                                                BoxT);
  400.                                    ClearText((MidX-Cnt*Tmp)+1,(MidY-Cnt)+1,
  401.                                                (MidX+Cnt*Tmp)-1,(MidY+Cnt)-1,
  402.                                                F,B);
  403.                                    For DR := 65535 DownTo ExplodeSpeed DO ;
  404.                              End;
  405.  DrawFillBox(X,Y,X1,Y1,F,B,BoxT);
  406. End;
  407.  
  408. Procedure PlainWriteVert(X,Y : Byte;Txt : String);
  409. Var Len,
  410.      Cnt : Byte;
  411. Begin
  412.  Len := Length(Txt) + Y-1;
  413.  For Cnt := Y To Len Do PlainWrite(X,Cnt,Txt[Cnt-Y+1])
  414. End;
  415.  
  416. Procedure ColorWriteVert(X,Y,F,B : Byte;Txt : String);
  417. Var Len,
  418.      Cnt : Byte;
  419. Begin
  420.  Len := Length(Txt) + Y-1;
  421.  For Cnt := Y To Len Do ColorWrite(X,Cnt,F,B,Txt[Cnt-Y+1])
  422. End;
  423.  
  424. Procedure PlainHorizLine(X,X1,Y,LineType : Byte);
  425. Begin
  426.  If X1 <= X Then FastError(1);
  427.  PlainWrite(X,Y,ReplicateChar(X1-X+1,Box[LineType].UpHLine));
  428. End;
  429.  
  430. Procedure ColorHorizLine(X,X1,Y,F,B,LineType : Byte);
  431. Begin
  432.  If X1 <= X Then FastError(1);
  433.  ColorWrite(X,Y,F,B,ReplicateChar(X1-X+1,Box[LineType].UpHLine));
  434. End;
  435. Procedure PlainVertLine(X,Y,Y1,LineType : Byte);
  436. Begin
  437.  If Y1 <= Y Then FastError(1);
  438.  PlainWriteVert(X,Y,ReplicateChar(Y1-Y+1,Box[LineType].LeftVLine));
  439. End;
  440. Procedure ColorVertLine(X,Y,Y1,F,B,LineType : Byte);
  441. Begin
  442.  If Y1 <= Y Then FastError(1);
  443.  ColorWriteVert(X,Y,F,B,ReplicateChar(Y1-Y+1,Box[LineType].LeftVLine));
  444. End;
  445. Procedure PlainWriteCenter(Line : Byte;Txt : String);
  446. Var Mid : Byte;
  447. Begin
  448.  Mid := Length(Txt) Div 2;
  449.  PlainWrite(40-Mid,Line,Txt);
  450. End;
  451. Procedure ColorWriteCenter(Line,F,B : Byte;Txt : String);
  452. Var Mid : Byte;
  453. Begin
  454.  Mid := Length(Txt) Div 2;
  455.  ColorWrite(40-Mid,Line,F,B,Txt);
  456. End;
  457. Procedure PlainWriteBetween(X,X1,Y : Byte; Txt : String);
  458. Var TMid,PMid : Byte;
  459. Begin
  460.  Tmid := Length(Txt) Div 2;
  461.  Pmid := X + ((X1-X) Div 2);
  462.  PlainWrite(PMid-TMid,Y,Txt);
  463. End;
  464. Procedure ColorWriteBetween(X,X1,Y,F,B : Byte; Txt : String);
  465. Var TMid,PMid : Byte;
  466. Begin
  467.  Tmid := Length(Txt) Div 2;
  468.  Pmid := X + ((X1-X) Div 2);
  469.  ColorWrite(PMid-TMid,Y,F,B,Txt);
  470. End;
  471. {===========================================================================
  472.                  ** OTHER ROUTINES **
  473.  ===========================================================================}
  474.  
  475.  
  476. Function Attrib(F,B : Byte) : Byte;
  477. Var t : Byte;
  478. Begin
  479.  Attrib := (B shl 4) + F;
  480. End;
  481.  
  482.  Function ReplicateChar(N : Byte; Ch : Char) : String;
  483.  Var i : Byte;
  484.    Res : String;
  485.  Begin
  486.    Res :='';
  487.    For i := 1 to N do Res := Res + Ch;
  488.    ReplicateChar := Res;
  489.  End;
  490. Procedure SetBlink (Stat : Boolean); assembler;
  491. asm
  492.     MOV BL,STAT { VGA ONLY }
  493.     MOV AX,1003h
  494.      INT 10h
  495. End;
  496. Procedure FillScreen(F,B : Byte; Ch : Char);
  497.  Var Cnt : Byte;
  498.      Tmp : String[80];
  499. Begin
  500.  Tmp := ReplicateChar(80,ch);
  501.  For Cnt := 1 To 25 Do ColorWrite(1,Cnt,F,B,Tmp);
  502. End;
  503. Procedure PartFillScreen(X,Y,X1,Y1,F,B : Byte; Ch : Char);
  504.  Var Cnt : Byte;
  505.      Tmp : String[80];
  506. Begin
  507.  Tmp := ReplicateChar(X1-X+1,ch);
  508.  For Cnt := Y to Y1 Do ColorWrite(X,Cnt,F,B,Tmp);
  509. End;
  510. Procedure ScrollUp(X,Y,X1,Y1,Num,Attr : Byte); assembler;
  511. asm
  512.    MOV AL,Num
  513.    MOV BH,Attr
  514.    MOV CH,Y
  515.    MOV CL,X
  516.    MOV DH,Y1
  517.    MOV DL,X1
  518.    DEC CL
  519.    DEC CH
  520.    DEC DL
  521.    DEC DH
  522.    MOV AH,6
  523.     INT 10h
  524. end;
  525. Procedure ScrollDown(X,Y,X1,Y1,Num,Attr : Byte); assembler;
  526. asm
  527.    MOV AL,Num
  528.    MOV BH,Attr
  529.    MOV CH,Y
  530.    MOV CL,X
  531.    MOV DH,Y1
  532.    MOV DL,X1
  533.    DEC CL
  534.    DEC CH
  535.    DEC DL
  536.    DEC DH
  537.    MOV AH,7
  538.     INT 10h
  539.  
  540. end;
  541.  
  542. Procedure InitVTFast;
  543.  
  544.  Begin
  545.   VideoInfo := DetectVideo;
  546.   If ColorScreen Then VSeg := $B800
  547.   Else VSeg := $0B000;
  548.   VPage := CurrentPage;
  549.   VOff :=  Vpage * VPageL;
  550.   With Box[0] Do Begin
  551.                      LeftVLine  := ' ';     RightVline := ' ';
  552.                      UpHline    := ' ';     DownHline  := ' ';
  553.                      LUCorner   := ' ';     RUCorner   := ' ';
  554.                      LDCorner   := ' ';     RDCorner   := ' ';
  555.                   End;
  556.  
  557.   With Box[1] Do Begin
  558.                      LeftVLine  := '│';     RightVline := '│';
  559.                      UpHline    := '─';     DownHline  := '─';
  560.                      LUCorner   := '┌';     RUCorner   := '┐';
  561.                      LDCorner   := '└';     RDCorner   := '┘';
  562.                   End;
  563.   With Box[2] Do Begin
  564.                      RightVline := '║';     LeftVline  := '║';
  565.                      UpHline    := '═';     DownHline  := '═';
  566.                      LUCorner   := '╔';     RUCorner   := '╗';
  567.                      LDCorner   := '╚';     RDCorner   := '╝';
  568.                   End;
  569.   GetCursor(CursorTop,CursorBot);
  570.  End; {INITVTFAST}
  571.  
  572. BEGIN
  573.  InitVTFast;
  574. END.
  575.